home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / genera-low.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  14KB  |  424 lines
  1. ;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; This is the 3600 version of the file portable-low.
  28. ;;;
  29.  
  30. (in-package 'pcl)
  31.  
  32. (pushnew ':pcl-internals dbg:*all-invisible-frame-types*)
  33.  
  34. #+IMach                        ;On the I-Machine these are
  35. (eval-when (compile load eval)            ;faster than the versions
  36.                         ;that use :test #'eq.  
  37. (defmacro memq (item list) `(member ,item ,list))
  38. (defmacro assq (item list) `(assoc ,item ,list))
  39. (defmacro rassq (item list) `(rassoc ,item ,list))
  40. (defmacro delq (item list) `(delete ,item ,list))
  41. (defmacro posq (item list) `(position ,item ,list))
  42.  
  43. )
  44.  
  45. compiler::
  46. (defoptimizer (cl:the the-just-gets-in-the-way-of-optimizers) (form)
  47.   (matchp form
  48.     (('cl:the type subform)
  49.      (ignore type)
  50.      subform)
  51.     (* form)))
  52.  
  53. (defmacro %ash (x count)
  54.   (if (and (constantp count) (zerop (eval count)))
  55.       x
  56.       `(the fixnum (ash (the fixnum ,x ) ,count))))
  57.  
  58. ;;;
  59. ;;;
  60. ;;;
  61.  
  62. (defmacro without-interrupts (&body body)
  63.   `(let ((outer-scheduling-state si:inhibit-scheduling-flag)
  64.      (si:inhibit-scheduling-flag t))
  65.      (macrolet ((interrupts-on  ()
  66.           '(when (null outer-scheduling-state)
  67.              (setq si:inhibit-scheduling-flag nil)))
  68.         (interrupts-off ()
  69.           '(setq si:inhibit-scheduling-flag t)))
  70.        (progn outer-scheduling-state)
  71.        ,.body)))
  72.  
  73. ;;;
  74. ;;; It would appear that #, does not work properly in Genera.  At least I can't get it
  75. ;;; to work when I use it inside of std-instance-p (defined later in this file).  So,
  76. ;;; all of this is just to support that.
  77. ;;;
  78. ;;;     WHEN                       EXPANDS-TO
  79. ;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
  80. ;;;   compile to core            '<result of evaluating form>
  81. ;;;   not in compiler at all     (progn <form>)
  82. ;;;
  83. ;;; Believe me when I tell you that I don't know why it is I need both a
  84. ;;; transformer and an optimizer to get this to work.  Believe me when I
  85. ;;; tell you that I don't really care why either.
  86. ;;;
  87. (defmacro load-time-eval (form)
  88.   ;; The interpreted definition of load-time-eval.  This definition
  89.   ;; never gets compiled.
  90.   (let ((value (gensym)))
  91.     `(multiple-value-bind (,value)
  92.      (progn ,form)
  93.        ,value)))
  94.  
  95. (compiler:deftransformer (load-time-eval optimize-load-time-eval) (form)
  96.   (compiler-is-a-loser-internal form))
  97.  
  98. (compiler:defoptimizer (load-time-eval transform-load-time-eval) (form)
  99.   (compiler-is-a-loser-internal form))
  100.  
  101. (defun compiler-is-a-loser-internal (form)  
  102.   ;; When compiling a call to load-time-eval the compiler will call
  103.   ;; this optimizer before the macro expansion.
  104.   (if zl:compiler:(and (boundp '*compile-function*)    ;Probably don't need
  105.                                 ;this boundp check
  106.                                 ;but it can't hurt.
  107.                (funcall *compile-function* :to-core-p))
  108.       ;; Compiling to core.
  109.       ;; Evaluate the form now, and expand into a constant
  110.       ;; (the result of evaluating the form).
  111.       `',(eval (cadr form))
  112.       ;; Compiling to a file.
  113.       ;; Generate the magic which causes the dumper compiler and loader
  114.       ;; to do magic and evaluate the form at load time.
  115.       `',(cons compiler:eval-at-load-time-marker (cadr form))))
  116.  
  117. ;;   
  118. ;;;;;; Memory Block primitives.                ***
  119.   ;;   
  120.  
  121.  
  122. (defmacro make-memory-block (size &optional area)
  123.   `(make-array ,size :area ,area))
  124.  
  125. (defmacro memory-block-ref (block offset)    ;Don't want to go faster yet.
  126.   `(aref ,block ,offset))
  127.  
  128. (defvar class-wrapper-area)
  129. (eval-when (load eval)
  130.   (si:make-area :name 'class-wrapper-area
  131.         :room t
  132.         :gc :static))
  133.  
  134. (eval-when (compile load eval)
  135.   (remprop '%%allocate-instance--class 'inline))
  136.  
  137. (eval-when (compile load eval)
  138.   
  139. (scl:defflavor std-instance
  140.     ((wrapper nil)
  141.      (slots   nil))
  142.     ()
  143.   (:constructor %%allocate-instance--class())
  144.   :ordered-instance-variables)
  145.  
  146. (defvar *std-instance-flavor* (flavor:find-flavor 'std-instance))
  147.  
  148. )
  149.  
  150. #-imach
  151. (scl:defsubst pcl-%instance-flavor (instance)
  152.   (declare (compiler:do-not-record-macroexpansions))
  153.   (sys::%make-pointer sys:dtp-array
  154.               (sys:%p-contents-as-locative
  155.             (sys:follow-structure-forwarding instance))))
  156.  
  157. #+imach
  158. (scl:defsubst pcl-%instance-flavor (instance)
  159.   (sys:%instance-flavor instance))
  160.  
  161. (scl::defsubst std-instance-p (x)
  162.   (and (sys:instancep x)
  163.        (eq (pcl-%instance-flavor x) (load-time-eval *std-instance-flavor*))))
  164.  
  165. (scl:defmethod (:print-self std-instance) (stream depth slashify)
  166.   (declare (ignore slashify))
  167.   (print-std-instance scl:self stream depth))
  168.  
  169. (scl:defmethod (:describe std-instance) ()
  170.   (describe-object scl:self *standard-output*))
  171.  
  172. (defmacro %std-instance-wrapper (std-instance)
  173.   `(sys:%instance-ref ,std-instance 1))
  174.  
  175. (defmacro %std-instance-slots (std-instance)
  176.   `(sys:%instance-ref ,std-instance 2))
  177.  
  178. (scl:compile-flavor-methods std-instance)
  179.  
  180.  
  181. (defun printing-random-thing-internal (thing stream)
  182.   (format stream "~\\si:address\\" (si:%pointer thing)))
  183.  
  184. ;;;
  185. ;;; This is hard, I am sweating.
  186. ;;; 
  187. (defun function-arglist (function) (zl:arglist function t))
  188.  
  189. (defun function-pretty-arglist (function) (zl:arglist function))
  190.  
  191.  
  192. ;; New (& complete) fspec handler.
  193. ;;   1. uses a single #'equal htable where stored elements are (fn . plist)
  194. ;;       (maybe we should store the method object instead)
  195. ;;   2. also implements the fspec-plist operators here.
  196. ;;   3. fdefine not only stores the method, but actually does the loading here!
  197. ;;
  198.  
  199. ;;;
  200. ;;;  genera-low.lisp (replaces old method-function-spec-handler)
  201. ;;;
  202.  
  203. ;; New (& complete) fspec handler.
  204. ;;   1. uses a single #'equal htable where stored elements are (fn . plist)
  205. ;;       (maybe we should store the method object instead)
  206. ;;   2. also implements the fspec-plist operators here.
  207. ;;   3. fdefine not only stores the method, but actually does the loading here!
  208. ;;
  209.  
  210. (defvar *method-htable* (make-hash-table :test #'equal :size 500))
  211. (sys:define-function-spec-handler method (op spec &optional arg1 arg2)
  212.   (if (eq op 'sys:validate-function-spec)
  213.       (and (let ((gspec (cadr spec)))
  214.          (or (symbolp gspec)
  215.          (and (listp gspec)
  216.               (eq (car gspec) 'setf)
  217.               (symbolp (cadr gspec))
  218.               (null (cddr gspec)))))
  219.        (let ((tail (cddr spec)))
  220.          (loop (cond ((null tail) (return nil))
  221.              ((listp (car tail)) (return t))
  222.              ((atom (pop tail)))             
  223.              (t (return nil))))))
  224.       (let ((table *method-htable*)
  225.         (key spec))
  226.     (case op
  227.       ((si:fdefinedp si:fdefinition)
  228.        (car (gethash key table nil)))
  229.       (si:fundefine
  230.         (remhash key table))
  231.       (si:fdefine
  232.         (let ((old (gethash key table nil))
  233.           (quals nil)
  234.           (specs nil)
  235.           (ptr (cddr spec)))
  236.           (setq specs
  237.             (loop (cond ((null ptr) (return nil))
  238.                 ((listp (car ptr)) (return (car ptr)))
  239.                 (t (push (pop ptr) quals)))))
  240.           (setf (gethash key table) (cons arg1 (cdr old)))))
  241.       (si:get
  242.         (let ((old (gethash key table nil)))
  243.           (getf (cdr old) arg1)))
  244.       (si:plist
  245.         (let ((old (gethash key table